home *** CD-ROM | disk | FTP | other *** search
/ MacTech 1 to 12 / MacTech-vol-1-12.toast / Source / MacTech® Magazine / Volume 05 - 1989 / 05.06 Jun 89 / Lisp sources / structures / animatedTower < prev    next >
Encoding:
Text File  |  1988-06-01  |  4.1 KB  |  105 lines  |  [TEXT/CCL ]
  1. ; Ted Kaehler and Dave Patterson: a taste of SmallTalk
  2. ; W. W. Norton ed., chapter 5, pp. 65 ff.
  3. ; translated in Allegro Common Lisp by Jean-Pascal J. LANGE.
  4. ; © Copyright 1988 Jean-Pascal J. LANGE.
  5.  
  6. (proclaim '(optimize (speed 3)
  7.             (space 0)
  8.             (safety 0)
  9.             (compilation-speed 0) ))
  10.  
  11. (defStruct (animatedTowerOfHanoi (:include HanoiTower))
  12. #| This structure represents the game. It inherits the variable stacks
  13.    from structure HanoiTower.
  14.    The variables are:
  15.      howMany: the number of disks,
  16.      mockDisks: an array of fake disks (when a disk asks what disk it
  17.                 can move on top of, and the pole is empty, we return
  18.                 a mock disk; it has nearly infinite width). |#
  19.   (howMany nil)
  20.   (mockDisks nil) )
  21.  
  22. ; the game
  23.  
  24. (deFun animatedHanoi (animatedTower)
  25.   ; asks the user how many disks, set up the game and move disks until
  26.   ; we are done.
  27.   (declare (special *TheTowers* *Thickness* *DiskGap*))
  28.   (do ()
  29.       ((integerp (howMany animatedTower)))
  30.     (format t "~&Please type the number of disks in the tower: ")
  31.     (setf (animatedTowerOfHanoi-howMany animatedTower) (read)) )
  32.   (oneOf *window*
  33.          :window-title "animated towers of Hanoï"
  34.          :window-position #@(20 100)
  35.          :window-size #@(360 220)
  36.          :window-type :single-edge-box )
  37.   (setUpDisks animatedTower)     ; create the disks and stacks
  38.   (moveTower animatedTower
  39.              (howMany animatedTower) 1 3 2 )
  40.   (setf (animatedTowerOfHanoi-howMany animatedTower) nil)
  41.   (makUnbound '*TheTowers*)
  42.   (makUnbound '*Thickness*)
  43.   (makUnbound '*DiskGap*)
  44.   nil ) ; animatedHanoi
  45.  
  46. (deFun setUpDisks (animatedTower)
  47.   ; Creates the disks and set up the poles. Tells all disks what game
  48.   ; they are in and set disk thickness and gap.
  49.   (whichTowers animatedTower)
  50.   (let ((displayBox (originCorner #@(0 0)
  51.                                   (ask (front-window) (window-size)) ) ) )
  52.     (erase displayBox)
  53.     (border displayBox 2) )
  54.   ; the poles are an array of three stacks. Each stack is a list.
  55.   (setf (animatedTowerOfHanoi-stacks animatedTower)
  56.         (make-array 3 :initial-element nil) )
  57.   (let ((disk)
  58.         (size (howMany animatedTower)) )
  59.     (doTimes (i (howMany animatedTower))
  60.       (setq disk (make-HanoiDisk))        ; create a disk
  61.       (widthPole disk size 1)
  62.       ; don't forget: the first element of an array is at index 0 !!!
  63.       (addFirst (animatedTowerOfHanoi-stacks animatedTower) 0 disk)             ; push it onto a stack
  64.       (invert disk)                  ; show on the screen
  65.       (setq size (1- size)) ) )
  66.   
  67.   ; When a pole has no disk on it, one of these mock disks acts as a
  68.   ; bottom disk. A moving disk will ask a mock disk its width and pole number.
  69.   (setf (animatedTowerOfHanoi-mockDisks animatedTower)
  70.         (make-array 3 :initial-element nil) )
  71.   (let ((disk))
  72.     (doTimes (index 3)
  73.       (setq disk (make-HanoiDisk))
  74.       ; don't forget: a doTimes-loop index starts at 0 !!!
  75.       (widthPole disk 1000 (1+ index))
  76.       ; don't forget: the first element of an array is at index 0 !!!
  77.       (setf
  78.        (aRef (animatedTowerOfHanoi-mockDisks animatedTower) index)
  79.        disk ) ) ) )
  80.  
  81. (deFun moveDisk (animatedTower fromPin toPin)
  82.   ; move disk from a pin to another pin.
  83.   ; Print the results in the listener window.
  84.   (let ((supportDisk  
  85.          ; don't forget: the first element of an array is at index 0 !
  86.          (if (aRef (animatedTowerOfHanoi-stacks animatedTower)
  87.                    (1- toPin) )
  88.            (car (aRef (animatedTowerOfHanoi-stacks animatedTower)
  89.                       (1- toPin) ))
  90.            (aRef (animatedTowerOfHanoi-mockDisks animatedTower)
  91.                  (1- toPin)) ) )
  92.         (disk (getAndRemoveFirst
  93.                (animatedTowerOfHanoi-stacks animatedTower)
  94.                (1- fromPin) )) )
  95.     (addFirst (animatedTowerOfHanoi-stacks animatedTower)
  96.               (1- toPin) disk)
  97.     ; inform the disk and show move
  98.     (moveUpon disk supportDisk)
  99.     #|(format t "~&~D -> ~D: ~A" fromPin toPin (name disk))|# )
  100.   #|(sleep 0.3)|# ) ; moveDisk
  101.  
  102. (deFun howMany (animatedTower)
  103.   ; returns the number of disks
  104.   (animatedTowerOfHanoi-howMany animatedTower) )
  105.